C
C     This file contains routines which call system specific functions.
C     CYBER 170 version, including some COMPASS routines.
C     IDENT JOBJE must be compiled with ..,S,S=PSSTEXT,..
C     IDENT CMPILY must be included in your program(s) !!!
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
          IDENT  JOBJE       GET JOBPARAMETERS IN COMMON /JOBDAT/
*                            COMPILE WITH ..,S,S=PSSTEXT,..
*                            CALL AS SUBROUTINE WITHOUT ARGUMENTS
          ENTRY  JOBJE
JOBJE     EQ     *+1S17
          SX6    A0
          SA6    TEMPA0
          GETJN  JN          GET JOBNAME
          GETASL ASL         GET ACCOUNTBLOCK SRU LIMIT
          GETTL  TL          GET JOBSTEP TIME LIMIT
          GETJO  IAF         GET JOB ORIGIN TYPE
          SX7    0
          SA1    IAF
          SB2    X1-3
          NZ     B2,FALSE
          SX7    X7-1        SET X7 TO .TRUE. IF IAF=3
FALSE     SA7    IAF         PUT X7 IN IAF
          SA3    TEMPA0
          SA0    X3
          EQ     JOBJE
          USE    TEMPS.
TEMPA0    BSS    1
          USE    /JOBDAT/
JN        BSS    1
ASL       BSS    1
TL        BSS    1
IAF       BSS    1
          END
C
C
C
      SUBROUTINE CMPILX
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     CMPILX retrieves compilation date and time
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      INCLUDE 'COM_JOBD.INC'
C
      COMMON /CMPXXX/ A,B
      WRITE (CMPDAT,'(A10)') A
      WRITE (CMPTIM,'(A10)') B
      RETURN
      END
C*****
C----- and include the next COMPASS routine in your program (!!)
C*****
C
          IDENT  CMPILY
          USE    /CMPXXX/
          DATA R*"DATE"*,R*"TIME"*
          BSS    9D
          END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
          IDENT  SETR1G      SET O.S. FLAG R1G TO VALUE AT ADDRESS IN A1
*                            CALL AS: CALL SETR1G(IFLAG)
          ENTRY  SETR1G
          USE    TEMPS.
TEMPA0    BSS    1
          USE
XAD       BSSZ   2
SETR1G    EQ     *+1S17
          SX6    A0
          SA0    A1          SAVE A1
          SA6    TEMPA0      SAVE PREVIOUS A0
          GETJCI XAD         GET SYSTEMINFORMATION
          SA2    XAD
          MX3    18D
          LX3    54
          BX5    -X3*X2
          SA4    A0
          SA4    X4          GET ARGUMENT PASSED TO ROUTINE
          LX4    36
          BX6    X4+X5       CHANGE R1G-FIELD
          SA6    XAD
          SETJCI XAD         PUT SYSTEMINFORMATION
          SA3    TEMPA0
          SA0    X3          RESTORE A0
          EQ     SETR1G
          END
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
          IDENT  IGTR1G     FUNCTION GETS VALUE OF R1G
*                           CALL AS: IFLAG=IGTR1G()
          ENTRY  IGTR1G
XAD       BSSZ   2
TEMPA0    BSS    1
IGTR1G    EQ     *+1S17
          SX6    A0
          SA6    TEMPA0      SAVE A0
          GETJCI XAD
          SA1    XAD
          LX1    -36
          MX2    -18D
          BX6    -X2*X1      PUT R1G VALUE AT FUNCTION-NAME ADDRESS
          SA3    TEMPA0
          SA0    X3          RESTORE A0
          EQ     IGTR1G
          END
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
          IDENT  JOBORG      LOGICAL FUNCTION GETS VALUE OF ORIGIN TYPE
*                            CALL AS IAF=JOBORG(), WHERE IAF AND JOBORG
*                            ARE BOTH OF TYPE LOGICAL
          ENTRY  JOBORG
XAD       BSSZ   1
TEMPA0    BSS    1
JOBORG    EQ     *+1S17
          SX7    A0
          SA7    TEMPA0      SAVE A0
          GETJO  XAD
          SX6    0
          SA1    XAD
          SB2    X1-3
          NZ     B2,FALSE
          SX6    X6-1        SET X6 TO .TRUE. IF OT=3
FALSE     SA3    TEMPA0
          SA0    X3          RESTORE A0
          EQ     JOBORG
          END
C
C
C
      CHARACTER*(*) FUNCTION GETDAT
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     GETDAT sets current date
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      GETDAT=DATE()
      RETURN
      END
C
C
C
      CHARACTER*(*) FUNCTION GETTIM
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     GETTIM sets current time
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      GETTIM=TIME()
      RETURN
      END
C
C
C
C      SUBROUTINE SYSTEM(NERR,STRING)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     SYSTEM forces fatal (NERR=52) or non-fatal (NERR=51) error
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C---------- CYBER 170 version: SYSTEM is routine in operating system library
C
C
      SUBROUTINE MESSGE(STRING,OPTION)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Subroutine MESSGE writes a string to the job dayfile (logfile),
C     to a communication area (o.s. dependent) or the permanent file history.
C     option = 'DAYF' : job dayfile
C                       (also histry if .not. iaf and medium or long job;
C                        CYBER only)
C            = 'HIST' : history file (see subr. histry)
C            = 'DISP' : status message to a 'display' (communication area)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      INCLUDE 'COM_JOBD.INC'
C
      CHARACTER STRING*(*), OPTION*4, STR*80
C
C
      IF ((OPTION.EQ.'DAYF'.AND.LSRU.GT.100.AND..NOT.IAF) .OR.
     +    OPTION.EQ.'HIST') THEN
         CALL HISTRY(STRING)
         IF (OPTION.EQ.'HIST') RETURN
      ENDIF
C
C----- PREPARE FOR CALL TO KONTRL:
C      IOP=4 : DAYFILE
C      IOP=1 : STATUS DISPLAY
C
      IOP=4
      IF (OPTION.EQ.'DISP') IOP=1
      I=LEN(STRING)
      J=I/10*10
      STR(J+1:J+10)='          '
      IF (J.LT.70) THEN
         DO 11 K=J+1,J+10
   11    STR(K:K)=':'
      ENDIF
      STR(1:I)=STRING
      CALL KONTRL(STR,IOP)
      RETURN
      END
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
          IDENT   KONTRL      DISPLAY MESSAGE AT CONTROL POINT
*                             AND/OR WRITE IT TO USER DAYFILE
*                             2 PARAMETERS: 'MESSAGE', OPTION
*                             OPTION=1 ==> DISPLAY;  =4 ==> USER DAYFILE
*                             CALL AS: CALL KONTRL(STR,IOP)
          ENTRY   KONTRL
KONTRL    EQ      *+1S17
          SA2     A1+1
          SA2     X2          2ND WORD OF PARAMETER LIST
          MX3     36D
          BX4     -X3
          BX5     X4*X1       SET UPPER 36 BITS OF 1ST WORD PAR.LIST TO
          MESSAGE X5,X2,R
          EQ      KONTRL
          END
C
C
C
      SUBROUTINE HISTRY(STRING)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Subroutine HISTRY writes a string to a permanent file history.
C     The file is retrieved before and replaced after the operation.
C     Together with the string the jobsystemname JOBNAM, date and time are
C     written. The information is put after the last line with the same
C     JOBNAM, or at the end of file.
C     JOBNAM in /JOBDAT/ should contain the jobsystemname (left justified,
C     zero fill to the right; see subr. JOBJE)
C     The string should no be longer than 55 characters.
C     HISTRY uses file-unitnumbers 998 and 999.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      CHARACTER LINE*76,STRING*(*),HIST*7,KLAD*7,DATE*10,TIME*10
      LOGICAL FOUND,WRIT
      DATA HIST,KLAD/'HISTORY','ZZZHIST'/
C
    1 FORMAT(A4,A)
    2 FORMAT(A4,2A,1X,A)
C
      LE=MIN0(LEN(STRING),55)
      FOUND=.FALSE.
      WRIT=.FALSE.
      OPEN (999,FILE=KLAD,BUFL=65)
      CALL PF('GET',0,HIST,'RC',I)
      IF (I.NE.0) GOTO 10
      OPEN (998,FILE=HIST,BUFL=65)
    5 READ (998,1,END=10) LL,LINE
      LL=LL.AND.O"77777777000000000000"
      IF (FOUND.AND.LL.NE.JOBNAM) THEN
        WRITE (999,2) JOBNAM,DATE(),TIME(),STRING(1:LE)
        WRIT=.TRUE.
      ENDIF
      FOUND=LL.EQ.JOBNAM
      WRITE (999,1) LL,LINE
      GOTO 5
   10 IF (.NOT.WRIT) WRITE(999,2) JOBNAM,DATE(),TIME(),STRING(1:LE)
      CLOSE (998)
      CLOSE (999)
      CALL PF('REPLACE',KLAD,HIST,'RC',I)
      RETURN
      END
C
C
C
      SUBROUTINE GETCPT(TIM)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Subroutine GETCPT retrieves the accumulated CPU time in seconds.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      TIM=SECOND()
      RETURN
      END
C
C
C
      BOOLEAN FUNCTION SCRMBL(A)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     Function SCRMBL returns a bit pattern resulting from scrambling
C     the bit pattern of argument A.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      PARAMETER (N=6)
C---------- N SHOULD BE A DIVISOR OF 60
C
      BOOLEAN A,X,IA(N),J
C---------- MULTIPLICATIVE CONGRUENTIAL RANDOM NUMBER GENERATOR
C           'GOLDEN SECTION' MULTIPLIER
C           SEE  F.JAMES, REP.PROGR.PHYS.VOL.43, 1172 (1980)
      IRANDOM(I)=(I*IMULTIP).OR.1
      RANDOM(I)=O"17170000000000000000".OR.I
      DATA IMULTIP/43490275647445/
C
      LEN=60/N
      X=.NOT.MASK(60-LEN)
      K=60
      DO 10 I=1,N
      IA(I)=SHIFT(A.AND.X,K)
      K=K-LEN
   10 X=SHIFT(X,LEN)
      ISEED=A.AND..NOT.MASK(12)
      DO 20 I=1,N
      ISEED=IRANDOM(ISEED)
      K=IFIX(N*RANDOM(ISEED))+1
      ISEED=IRANDOM(ISEED)
      L=IFIX(N*RANDOM(ISEED))+1
      J=IA(K)
      IA(K)=IA(L)
   20 IA(L)=J
      X=IA(1)
      K=LEN
      DO 30 I=2,N
      X=X.OR.SHIFT(IA(I),K)
   30 K=K+LEN
      SCRMBL=X
      RETURN
      END
C
C
C
      FUNCTION LOCATE(A)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     LOCATE returns address of A.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      LOCATE=LOCV(A)
      RETURN
      END
C
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
          IDENT  LENCM       INTEGER FUNCTION GETS CURRENT CM FL
          ENTRY  LENCM
STAT      BSS    1
TEMPA0    BSS    1
LENCM     EQ     *+1S17
          SX7    A0
          SA7    TEMPA0      SAVE A0
          MX6    0
          SA6    STAT
          MEMORY CM,STAT,R
          SA2    STAT
          AX2    30          RIGHT SHIFT 30 BITS
          SX6    X2
          SA3    TEMPA0
          SA0    X3          RESTORE A0
          EQ     LENCM
          END
C
C
C
      SUBROUTINE MEMORY
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C     Subroutine MEMORY (de)allocates memory space. Address pointers
C     relative to V in blank common are calculated.
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      PARAMETER (ILEN=10)
      INTEGER V
      COMMON V(1)
      COMMON /MEMRY/ NR,MAX,IF(ILEN)
C
      DATA NR,MAX,IF /2*0, ILEN*1/
C
      ENTRY ADDCM(I,N)
      V(1)=0
      CALL ADDCM2(I,N+1)
      I=I+1
C---------- FIRST WORD: V(I)
      DO 10 J=I,I+N
   10 V(J)=O"17770000000000000000"
C---------- PRESET TO INDEFINITE
C
      IF (NR.LT.ILEN) THEN
        NR=NR+1
        IF(NR)=I
C---------- INDEX OF FIRST WORD
        V(I)=N
C---------- FIRST WORD = REQUIRED LENGTH
      ELSE
        MAX=MAX+1
      ENDIF
      I=I+1
C---------- AVAILABLE TO MAIN: SECOND WORD FF.
      RETURN
C
      ENTRY SHRCM(I,N)
      CALL SHRCM2(I-2,N)
      V(I-1)=V(I-1)-N
      RETURN
C
      ENTRY FREECM(I)
      CALL FREECM2(I-2)
      DO 20 J=1,NR
      IF(IF(J).EQ.I-1) THEN
        IF(J)=1
        IF (J.EQ.NR) NR=NR-1
        RETURN
      ENDIF
   20 CONTINUE
C
      ENTRY MAPCM(NT)
      K=LOCATE(V)
      WRITE (NT,30) NR,MAX,K,LENCM()-K,IF,(V(IF(J)),J=1,ILEN)
   30 FORMAT(//' BLANK COMMON MAP:',I5,' MAPPED,',I5,
     +' UNMAPPED BLOCKS,  START ADDRESS BLANK COMMON',I7,
     +',  RELATIVE END OF FL AT',I7/
     +' ARRAY INDICES',10I7/' BLOCK LENGTHS',10I7/)
      RETURN
      END
          IDENT  MEMRYC
          ENTRY  ADDCM2,FREECM2,SHRCM2
* ALLOCATE, DEALLOCATE OR SHRINK A BLOCK OF MEMORY WITH CMM
* OFFSET: ADDRESS COMPUTED RELATIVE TO A(1) IN BLANK COMMON
* ENTRY : CALL ADDCM2(I, N)
*         GIVES BLOCK OF N WORDS, A(I+1), ... ,A(I+N)
* ENTRY : CALL FREECM2(I)
*         FREES BLOCK STARTING WITH A(I+1)
* ENTRY : CALL SHRCM2(I, N)
*         SHRINKS BLOCK STARTING AT A(I+1) WITH THE LAST N WORDS
* USES:   CMM.ALF, CMM.FRF, CMM.SLF
* ------ DON'T CHANGE THE VALUE OF I----------------
*
          USE    //
V         BSS    1
          USE
 ADDCM2   EQ     *+1S17
          SA5    A1                SAVE ADDRESS I IN X5
          SA4    A5+1              ADDRESS BLOCK SIZE N IN X4
          SX3    200B              NO GROUP-ID, SIZE CODE 2B
          SA2    X4                FETCH BLOCK SIZE IN X2
          RJ   =XCMM.ALF           ALLOCATE FIXED POSITION BLOCK
*                                  NOTE: X5 IS SAVED, B1 := 1
          SX2    V                 X2 := FWA BLANK C.
          IX6    X1-X2             X6 := FWA BLOCK  -  FWA BLANK C.
          SA6    X5                 I := X6
          EQ   ADDCM2              RETURN TO CALLER
*         ------------
 FREECM2  EQ     *+1S17
          SX3    V                 X3 := FWA BLANK C.
          SA2    X1                X2 := I
          IX1    X2+X3             X1 := FWA BLOCK
          RJ   =XCMM.FRF           FREE FIXED POSITION BLOCK
          EQ   FREECM2             RETURN TO CALLER
*         ------------
SHRCM2    EQ     *+1S17
          SX3    V                 X3 := FWA BLANK C.
          SA2    X1                X2 := I
          IX1    X2+X3             X1 := FWA BLOCK
          SA4    A1+1              ADDRESS OF N IN X4
          SA2    X4                X2 := N
          RJ   =XCMM.SLF           SHRINK FIXED POSITION BLOCK
          EQ     SHRCM2
          END
          IDENT  CMMOP4
          ENTRY  CMMOP4
CMMOP4    EQ     *+1S17
          RJ   =XCMM.OP4
          EQ     CMMOP4
          END
C
C
C
      SUBROUTINE MAKRAN(I)
C***********************************************************************
C     MAKRAN generates a 'random' bit pattern in I
C***********************************************************************
C
      BOOLEAN SCRMBL,DATE,TIME
      D=DATE()
      T=TIME()
      I=(SCRMBL(TIME).XOR.SCRMBL(DATE)).AND..NOT.MASK(12)
      RETURN
      END
C
C
C
C      SUBROUTINE RANSET(ISEED)
C***********************************************************************
C     RANSET sets the seed in /RNDGEN/ to be used by RANGET
C     RANSET is in system library
C***********************************************************************
C      INTEGER SEED
C      COMMON /RNDGEN/ SEED
C      SEED=(ISEED/2)*2+1
C      RETURN
C      END
C
C
C
      SUBROUTINE RANGEN
C***********************************************************************
C     RANGEN initializes seed for RANGET by using MAKRAN
C***********************************************************************
      CALL MAKRAN(I)
      CALL RANSET(I)
      RETURN
      END
C
C
C
      FUNCTION RANGET
C***********************************************************************
C     RANGET calls random number routine with seed set by RANSET
C***********************************************************************
C      INTEGER SEED
C      COMMON /RNDGEN/ SEED
      RANGET=RANF()
      RETURN
      END
